home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Library-2.01 / MacTCP.Lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  36.4 KB  |  1,043 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;MacTCP.Lisp
  4. ;Copyright © 1991 Apple Computer, Inc.
  5. ;
  6. ; TCP streams.
  7. ;
  8. ; OPEN-TCP-STREAM creates a stream that does its I/O through a TCP port.
  9. ;
  10.  
  11. ; 04/28/93 mwp Release
  12. ; 01/22/93 bill Steve Weyer's fix to make stream-tyi return NIL at EOF.
  13. ; 06/05/92 bill remove (dbg length)
  14. ; 05/05/92 bill Narinder Singh's mods to add a timeout value for passive opens.
  15. ;-------------- 2.0
  16. ; 03/20/92 bill format string needed arg in (initialize-instance (binary-tcp-stream))
  17. ; 02/27/92 bill Derek's mods to ease subclassing of tcp-stream.
  18. ; -----------   2.0f3
  19. ; 02/05/92 gb   change record defs to more nearly match TCPPB.h, etc.
  20. ; 01/20/92 gb   minimal support for binary i/o.
  21. ; 12/24/91 gb   fix some bugs; look harder for the resolver.
  22. ;--------- 2.0b4
  23. ; 08/20/91 bill %get-cstr -> %get-cstring
  24. ; 05/20/91 gb   Still needs work.
  25. ; 01/10/91 bill Remove LAP
  26. ; 05/08/90 gz   Released
  27.  
  28. (in-package :ccl)
  29.  
  30. (eval-when (:compile-toplevel :load-toplevel :execute)
  31.   (export '(open-tcp-stream)))
  32.  
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34. ;Definitions
  35.  
  36. ;TCP csCodes
  37. (defconstant $ipctlGetAddr 15)
  38. (defconstant $TCPCreate 30)
  39. (defconstant $TCPPassiveOpen 31)
  40. (defconstant $TCPActiveOpen 32)
  41. (defconstant $TCPSend 34)
  42. (defconstant $TCPNoCopyRcv 35)
  43. (defconstant $TCPRcvBfrReturn 36)
  44. (defconstant $TCPRcv 37)
  45. (defconstant $TCPClose 38)
  46. (defconstant $TCPAbort 39)
  47. (defconstant $TCPStatus 40)
  48. (defconstant $TCPExtendedStat 41)
  49. (defconstant $TCPRelease 42)
  50. (defconstant $TCPGlobalInfo 43)
  51. (defconstant $TCPCtlMax 49)
  52.  
  53. ;TCP event codes
  54. (defconstant $TCPClosing 1)
  55. (defconstant $TCPULPTimeout 2)
  56. (defconstant $TCPTerminate 3)
  57. (defconstant $TCPDataArrival 4)
  58. (defconstant $TCPUrgent 5)
  59. (defconstant $TCPICMPReceived 6)
  60.  
  61. ;TCP termination reasons
  62. (defconstant $TCPRemoteAbort 2)
  63. (defconstant $TCPNetworkFailure 3)
  64. (defconstant $TCPSecPrecMismatch 4)
  65. (defconstant $TCPULPTimeoutTerminate 5)
  66. (defconstant $TCPULPAbort 6)
  67. (defconstant $TCPULPClose 7)
  68. (defconstant $TCPServiceError 8)
  69.  
  70. ;ValidityFlags
  71. (defconstant $TCPtimeoutValue #x80)
  72. (defconstant $TCPtimeoutAction #x40)
  73. (defconstant $TCPtypeOfService #x20)
  74. (defconstant $TCPprecedence #x10)
  75.  
  76. ;TOSFlags
  77. (defconstant $TCPlowDelay #x01)
  78. (defconstant $TCPthroughPut #x02)
  79. (defconstant $TCPreliability #x04)
  80.  
  81. ; error codes
  82. (defconstant $TCPTimeout -23016)
  83.  
  84. (eval-when (:compile-toplevel :load-toplevel :execute)
  85.  
  86. (defrecord IPParamBlock
  87.   (qLink pointer)
  88.   (qType integer)
  89.   (ioTrap integer)
  90.   (ioCmdAddr pointer)
  91.   (ioCompletion pointer)
  92.   (ioResult integer)
  93.   (ioNamePtr pointer)
  94.   (ioVRefNum integer)
  95.   (ioCRefNum integer)
  96.   (csCode integer)
  97.   (ourAddress unsigned-long)
  98.   (ourNetMask unsigned-long))
  99.  
  100. (defrecord tcpCreatePB
  101.   (rcvBuff pointer)
  102.   (rcvBuffLen longint)                 ; should be unsigned.
  103.   (notifyProc pointer)
  104.   (userDataPtr pointer))
  105.  
  106. (defrecord tcpReleasePB
  107.   (rcvBuff pointer)
  108.   (rcvBuffLen longint))
  109.   
  110. (defrecord tcpOpenPB
  111.   (ulpTimeoutValue byte)
  112.   (ulpTimeoutAction byte)
  113.   (validityFlags byte)
  114.   (commandTimeoutValue byte)
  115.   (remoteHost unsigned-long)
  116.   (remotePort integer)
  117.   (localHost unsigned-long)
  118.   (localPort integer)
  119.   (tosFlags byte)
  120.   (precedence byte)
  121.   (dontFrag byte)
  122.   (timeToLive byte)
  123.   (security byte)
  124.   (optionCnt byte)
  125.   (options (string 39))
  126.   (userDataPtr pointer))
  127.  
  128. (defrecord tcpSendPB
  129.   (ulpTimeoutValue byte)
  130.   (ulpTimeoutAction byte)
  131.   (validityFlags byte)
  132.   (pushFlag byte)
  133.   (urgentFlag byte)
  134.   (fill byte)
  135.   (wdsPtr pointer)
  136.   (sendFree longint)                    ; unsigned
  137.   (sendLength unsigned-integer)
  138.   (userDataPtr pointer))
  139.  
  140. (defrecord tcpReceivePB
  141.   (commandTimeoutValue byte)
  142.   (fill byte)
  143.   (markFlag byte)
  144.   (urgentFlag byte)
  145.   (rcvBuff pointer)
  146.   (rcvBuffLen unsigned-integer)
  147.   (rdsPtr pointer)
  148.   (rdsLength unsigned-integer)
  149.   (secondTimeStamp unsigned-integer)
  150.   (userDataPtr pointer))
  151.  
  152. (defrecord tcpClosePB
  153.   (ulpTimeoutValue byte)
  154.   (ulpTimeoutAction byte)
  155.   (validityFlags byte)
  156.   (fill byte)
  157.   (userDataPtr pointer))
  158.  
  159. (defrecord tcpAbortPB
  160.   (userDataPtr pointer))
  161.  
  162. (defrecord tcpStatusPB
  163.   (ulpTimeoutValue byte)
  164.   (ulpTimeoutAction byte)
  165.   (fill1 longint)
  166.   (remoteHost unsigned-long)
  167.   (remotePort unsigned-integer)
  168.   (localHost unsigned-long)
  169.   (localPort unsigned-integer)
  170.   (tosFlags byte)
  171.   (precedence byte)
  172.   (connectionState byte)
  173.   (fill2 byte)
  174.   (sendWindow unsigned-integer)
  175.   (rcvWindow unsigned-integer)
  176.   (amtUnackedData unsigned-integer)
  177.   (amtUnreadData unsigned-integer)
  178.   (securityLevelPtr pointer)
  179.   (sendUnacked longint)
  180.   (sendNext longint)
  181.   (congestionWindow longint)
  182.   (rcvNext longint)
  183.   (srtt longint)
  184.   (lastRTT longint)
  185.   (sendMaxSegSize longint)
  186.   (connStatPtr pointer)
  187.   (userDataPtr pointer))
  188.  
  189. (defrecord tcpGlobalInfoPB
  190.   (tcpParamPtr pointer)
  191.   (tcpStatsPtr pointer)
  192.   (tcpCDBTable pointer)
  193.   (userDataPtr pointer))
  194.  
  195. (defrecord tcpIOPB
  196.   (qLink pointer)
  197.   (qType integer)
  198.   (ioTrap integer)
  199.   (ioCmdAddr pointer)
  200.   (ioCompletion pointer)
  201.   (ioResult integer)
  202.   (ioNamePtr pointer)
  203.   (ioVRefNum integer)
  204.   (ioCRefNum integer)
  205.   (csCode integer)
  206.   (StreamPtr pointer)
  207.   (variant
  208.    ((create tcpCreatePB))
  209.    ((release tcpReleasePB))
  210.    ((open tcpOpenPB))
  211.    ((send tcpSendPB))
  212.    ((receive tcpReceivePB))
  213.    ((close tcpClosePB))
  214.    ((abort tcpAbortPB))
  215.    ((status tcpStatusPB))
  216.    ((globalinfo tcpGlobalInfoPB))))
  217.  
  218. (defrecord hostinfo
  219.   (rtnCode longint)
  220.   (cname (string 255))
  221.   (addr1 unsigned-long)
  222.   (addr2 unsigned-long)
  223.   (addr3 unsigned-long)
  224.   (addr4 unsigned-long)
  225.   ;This is our own extension...
  226.   (result integer))
  227.  
  228. ) ;defrecord eval-when
  229.  
  230. (defconstant $cacheFault -23042)
  231. (defconstant $tcpPBsize (record-length :tcpioPB))
  232.  
  233.  
  234. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  235. ; MacTCP.Lisp
  236.  
  237. (defparameter *service-name-number-alist*
  238.   '(("echo" . 7)
  239.     ("discard" . 9)                     ; sink null
  240.     ("systat" . 11)
  241.     ("daytime" . 13)
  242.     ("netstat"    . 15)
  243.     ("ftp-data" . 20)
  244.     ("ftp" . 21)
  245.     ("telnet" . 23)
  246.     ("smtp" . 25)
  247.     ("time" . 37)
  248.     ("name" . 32)                       ; (udp only)
  249.     ("whois" . 43)                      ; usually to sri-nic
  250.     ("domain" . 53)
  251.     ("hostnames" . 101)                 ; usually to sri-nic
  252.     ("sunrpc" . 111)
  253.     ("rje" . 77)
  254.     ("finger" . 79)
  255.     ("link" . 87)                       ; ttylink
  256.     ("supdup" . 95)
  257.     ("iso-tsap" . 102)
  258.     ;("x400" . 103)                      ; # ISO Mail
  259.     ("dictionary" . 103)
  260.     ("x400-snd" . 104)
  261.     ("csnet-ns" . 105)
  262.     ("pop" . 109)
  263.     ("uucp-path" . 117)
  264.     ("nntp" . 119)
  265.     ("ntp" . 123)
  266.     ("NeWS" . 144)
  267.     ; UNIX specific services
  268.     ;these are NOT officially assigned
  269.     ("exec" . 512)
  270.     ("login" . 513)
  271.     ("shell" . 514)
  272.     ("printer" . 515)                   ; spooler    # experimental
  273.     ("courier" . 530)                   ; rpc        # experimental
  274.     ("biff" . 512)                      ; (udp only) comsat
  275.     ("who" . 513)                       ; (udp only)
  276.     ("syslog" .    514)                    ; (udp only)
  277.     ("talk" . 517)                      ; (udp only)
  278.     ("route" . 520)                     ; (udp only)
  279.     ("new-rwho" . 550)                  ; (udp only)    # experimental
  280.     ("rmonitor" . 560)                  ; (udp only)     # experimental
  281.     ("monitor" . 561)                   ; (udp only)    # experimental
  282.     ("ingreslock" . 1524)
  283.     ("imap" . 143)))
  284.  
  285. (defvar *tcp-driver-refnum* nil)
  286. (defvar %resolver-code% nil)
  287. (defvar %tcp-set-result-proc% nil)
  288. (defvar %hinfo-record% nil)
  289. (defvar *open-tcp-streams* nil)
  290.  
  291. (def-load-pointers tcp ()
  292.   (let* ((code '(#x225f                  ; spop a1
  293.                  #x584f                  ; addq #4,sp
  294.                  #x205f                  ; spop a0
  295.                  #x3168 #x0002 #x0114    ; move.w 2(a0),hostinfo.result(a0)
  296.                  #x4ed1))                ; jmp (a1)
  297.          (codelen (length code)))
  298.     (setq *tcp-driver-refnum* nil)
  299.     (setq %resolver-code% nil)
  300.     (setq %tcp-set-result-proc% (let ((ptr (#_NewPtr (+ codelen codelen))))
  301.                                   (dotimes (i codelen ptr)
  302.                                     (%put-word ptr (pop code) (+ i i)))))
  303.     (setq %hinfo-record% (make-record :hostinfo))))
  304.  
  305. (defun tcp-driver-refnum ()
  306.   (or *tcp-driver-refnum*
  307.       (with-pstrs ((name ".ipp"))
  308.         (rlet ((pb hparamblockrec))
  309.           (setf (rref pb hparamblockrec.ionameptr) name
  310.                 (rref pb hparamblockrec.iocompletion) (%null-ptr)
  311.                 (rref pb hparamblockrec.ioPermssn) 0)
  312.           (#_open :errchk pb)
  313.           (setq *tcp-driver-refnum* (rref pb hparamblockrec.ioRefNum))))))
  314.  
  315. (defun  %tcp-control (pb code &optional ignore-error-p ignore-timeout)
  316.   (setf (rref pb tcpioPB.csCode) code
  317.         (rref pb tcpioPB.ioCompletion) (%null-ptr))
  318.   (let* ((err nil))
  319.     (progn
  320.         (loop
  321.           (when (eql (setq err (#_control :async pb)) 0)
  322.             (let* ((*interrupt-level* 0))
  323.               (while (> (setq err (rref pb tcpioPB.ioResult)) 0))))
  324.           (return))
  325.         (unless (or ignore-error-p (eql err 0)
  326.                     (and ignore-timeout (eql err $TCPTimeout)))
  327.           (%tcp-err-disp err))
  328.         err)))
  329.  
  330. ;Timeout should be an arg...
  331. (defun tcp-active-open (address port &optional (bufsize 8192) notify-routine)
  332.   (let ((pb nil))
  333.     (unwind-protect
  334.       (progn
  335.         (setq pb (#_NewPtr :Clear :errchk (+ bufsize $tcpPBSize)))
  336.         (%tcp-create pb (%inc-ptr pb $tcpPBSize) bufsize notify-routine)
  337.         (%tcp-active-open pb address port)
  338.         (prog1 pb (setq pb nil)))
  339.       (when pb
  340.         (unless (%null-ptr-p (rref pb tcpioPB.streamPtr))
  341.           (setf (rref pb tcpioPB.csCode) $TCPRelease)
  342.           (#_Control pb))
  343.         (#_DisposPtr pb)))))
  344.  
  345. (defun %tcp-create (pb RcvBuff RcvBuffLen notifyProc)
  346.   (setf (rref pb tcpioPB.ioCRefNum) (tcp-driver-refnum)
  347.         (rref pb tcpioPB.create.RcvBuff) RcvBuff
  348.         (rref pb tcpioPB.create.RcvBuffLen) RcvBuffLen
  349.         (rref pb tcpioPB.create.notifyProc) (or notifyProc (%null-ptr)))
  350.   (%tcp-control pb $TCPCreate))
  351.  
  352. ; Wait for a connection (from any host, port) to us.
  353. (defun %tcp-passive-open (pb port &optional (timeout 30))
  354.   (setf (rref pb tcpioPB.open.validityFlags) 0
  355.         (rref pb tcpioPB.open.commandTimeoutValue) timeout
  356.         (rref pb tcpioPB.open.localPort) port
  357.         (rref pb tcpioPB.open.optionCnt) 0
  358.         (rref pb tcpioPB.open.remoteHost) 0
  359.         (rref pb tcpioPB.open.remotePort) 0
  360.         (rref pb tcpioPB.open.timeToLive) 0)      ; time-to-live = 60 hops
  361.   (%tcp-control pb $TCPPassiveOpen nil t))
  362.  
  363. (defun %tcp-active-open (pb address port)
  364.   (setf (rref pb tcpioPB.open.validityFlags) 0   ; let timeouts, etc default.
  365.         (rref pb tcpioPB.open.localPort) 0       ; default our port
  366.         (rref pb tcpioPB.open.timeToLive) 0      ; time-to-live = 60 hops
  367.         (rref pb tcpioPB.open.optionCnt) 0       ; What are TCP options?
  368.         (rref pb tcpioPB.open.localHost) (%tcp-getaddr)
  369.         (rref pb tcpioPB.open.remoteHost) address
  370.         (rref pb tcpioPB.open.remotePort) port)
  371.   (%tcp-control pb $TCPActiveOpen))
  372.  
  373. (defun %tcp-getaddr ()
  374.   (rlet ((pb :IPParamBlock))
  375.     (setf (rref pb IPParamBlock.ioCRefNum) (tcp-driver-refnum))
  376.     (%tcp-control pb $ipctlGetAddr)
  377.     (values (rref pb IPParamBlock.ourAddress)
  378.             (rref pb IPParamBlock.ourNetMask))))
  379.  
  380. (defun %tcp-send (pb bufptr buflen push-p)
  381.   (when (%i> buflen #xFFFF) (report-bad-arg buflen '(integer 0 #xFFFF)))
  382.   (%stack-block ((wds 8))
  383.     (%put-word wds buflen 0)
  384.     (%put-ptr wds bufptr 2)
  385.     (%put-word wds 0 6)
  386.     (setf (rref pb tcpioPB.send.wdsPtr) wds
  387.           (rref pb tcpioPB.send.pushFlag) (if push-p -1 0)
  388.           (rref pb tcpioPB.send.urgentFlag) 0
  389.           (rref pb tcpioPB.send.validityFlags) 0)
  390.     (%tcp-control pb $TCPSend)))
  391.  
  392. (defun tcp-send (pb string push-p)
  393.   (if (<= (length string) 1024)
  394.     (with-cstr (buf string)
  395.       (%tcp-send pb buf (length string) push-p))
  396.     (multiple-value-bind (sstr start end) (get-sstring string)
  397.       (declare (type fixnum start end))
  398.       (%stack-block ((buf 1024))
  399.         ; This code is untested because nobody calls TCP-SEND
  400.         (let ((sstr-ptr (%null-ptr))
  401.               len)
  402.           (declare (dynamic-extent sstr-ptr)
  403.                    (type macptr sstr-ptr)
  404.                    (type fixnum len))
  405.           (loop
  406.             (setq len (- end start))
  407.             (if (<= len 0) (return))
  408.             (if (< 1024 len) (setq len 1024))
  409.             (without-interrupts
  410.              (%address-to-macptr sstr sstr-ptr)
  411.              (#_BlockMove (%inc-ptr sstr-ptr (+ 7 start))  buf  len))
  412.             (setq start (+ start 1024))
  413.             (%tcp-send pb buf len (and push-p (>= start end)))))))))
  414.  
  415. (defun %address-to-macptr (address &optional (macptr (%null-ptr)))
  416.   (%setf-macptr macptr (%int-to-ptr (%address-of address))))
  417.  
  418. (defun %tcp-rcv (pb ptr len timeout)
  419.   (setf (rref pb tcpioPB.Receive.commandTimeoutValue) timeout
  420.         (rref pb tcpioPB.Receive.rcvBuff) ptr
  421.         (rref pb tcpioPB.Receive.rcvBuffLen) (require-type len '(integer 0 #xFFFF)))
  422.   (%tcp-control pb $TCPRcv)
  423.   (rref pb tcpioPB.Receive.rcvBuffLen))
  424.  
  425. (defun %tcp-bfrreturn (pb rds)
  426.   (setf (rref pb tcpioPB.Receive.rdsPtr) rds)
  427.   (%tcp-control pb $TCPRcvBfrReturn))
  428.  
  429. (defun %tcp-nocopyrcv (pb rdsptr rdslen timeout)
  430.   (setf (rref pb tcpioPB.Receive.commandTimeoutValue) timeout
  431.         (rref pb tcpioPB.Receive.rdsPtr) rdsptr
  432.         (rref pb tcpioPB.Receive.rdsLength) (require-type rdslen '(integer 0 #xFFFF)))
  433.   (%tcp-control pb $TCPNoCopyRcv))
  434.  
  435. (defun %tcp-close (pb)
  436.   (setf (rref pb tcpioPB.close.validityFlags) 0)
  437.   (%tcp-control pb $TCPClose))
  438.  
  439. (defun %tcp-abort (pb)
  440.   (%tcp-control pb $TCPAbort))
  441.  
  442. (defun %tcp-release (pb)                ; This does a TCPAbort...
  443.   (unless (%null-ptr-p (rref pb tcpioPB.StreamPtr))
  444.     (%tcp-control pb $TCPRelease)
  445.     (setf (rref pb tcpioPB.StreamPtr) (%null-ptr)))
  446.   nil)
  447.  
  448. (defun tcp-release (pb)
  449.   (unless (%null-ptr-p pb)
  450.     (%tcp-release pb)
  451.     (%setf-macptr pb (%null-ptr))))
  452.  
  453. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  454. (defconstant $openresolver 1)
  455. (defconstant $closeresolver 2)
  456. (defconstant $strtoaddr 3)
  457. (defconstant $addrtostr 4)
  458. (defconstant $enumcache 5)
  459. (defconstant $addrtoname 6)
  460.  
  461.  
  462. (defun find-system-folder ()
  463.   (let* ((wdrefnum 
  464.           (rlet ((info :SysEnvRec))
  465.             (#_SysEnvirons :errchk 1 info)
  466.             (rref info SysEnvRec.sysVRefNum))))
  467.     (rlet ((pb :hparamblockrec)
  468.            (nameptr :str31))
  469.       (setf (rref pb :hparamblockrec.ioWDIndex) 0
  470.             (rref pb :hparamblockrec.ionameptr) nameptr
  471.             (rref pb :hparamblockrec.ioVrefNum) wdrefnum
  472.             (rref pb :hparamblockrec.ioWDProcID) 0)
  473.       (if (eql #$noErr (#_GetWDInfo pb))
  474.         (values (rref pb :hparamblockrec.ioWDVrefNum)
  475.                 (rref pb :hparamblockrec.ioWDDirID))
  476.         (values nil nil)))))
  477.  
  478. (defun find-control-panels-folder ()
  479.   (let* ((vrefnum nil)
  480.          (dirID nil))
  481.     (when (logbitp #$gestaltFindFolderPresent
  482.                    (or (ccl::gestalt #$gestaltFindFolderAttr) 0))
  483.       (rlet ((vrefnumP :signed-integer)
  484.              (diridP :signed-long))
  485.         (when (eql #$noErr 
  486.                    (#_FindFolder 
  487.                     #$kOnSystemDisk 
  488.                     #$kControlPanelFolderType
  489.                     #$kDontCreateFolder
  490.                     vRefNumP
  491.                     dirIDP))
  492.           (setq vrefnum (%get-signed-word vrefnump)
  493.                 dirid (%get-signed-long diriDP)))))
  494.     (values vrefnum dirID)))
  495.  
  496. (defun %load-resolver-code ()
  497.   (or %resolver-code%
  498.       (multiple-value-bind (sysvrefnum sysdirid) (find-system-folder)
  499.         (multiple-value-bind (cpvrefnum cpdirid) (find-control-panels-folder)
  500.           (setq %resolver-code%
  501.                 (or 
  502.                  (%find-dnr "cdev" "ztcp" cpvrefnum sysdirid)    ; 1.1
  503.                  (%find-dnr "cdev" "mtcp" sysvrefnum sysdirid)  ; 1.0.x in system folder
  504.                  (%find-dnr "cdev" "mtcp" cpvrefnum cpdirid)    ; 1.0.x in control panels folder
  505.                  (error "Can't load MacTCP Domain Name Resolver")))))))
  506.  
  507. (defun %find-dnr (type creator vrefnum dirid)
  508.   ; Returns detached handle to DNRP resource or NIL.
  509.   (when vrefnum
  510.     (rlet ((name :str255)
  511.            (pb :hparamblockrec))
  512.       (setf (rref pb :hparamblockrec.ionameptr) name
  513.             (rref pb :hparamblockrec.iovrefnum) vrefnum
  514.             (rref pb :hparamblockrec.ioDirID) dirid
  515.             (rref pb :hparamblockrec.ioFDirIndex) 1)
  516.       (do* ()
  517.            ((not (eql #$noErr (#_HGetFinfo pb))) nil)
  518.         (if (and (string= (rref pb :hparamblockrec.ioFlFndrInfo.fdType) type)
  519.                  (string= (rref pb :hparamblockrec.ioFlFndrInfo.fdCreator) creator))
  520.           (let* ((refnum (#_HOpenResFile vrefnum dirid name #$fsRdPerm)))
  521.             (if (eql refnum -1)
  522.               (return nil)
  523.               (unwind-protect
  524.               (let* ((dnrp (#_Get1IndResource "dnrp" 1)))
  525.                 (unless (%null-ptr-p dnrp)
  526.                   (#_DetachResource dnrp)
  527.                   (#_CloseResFile refnum)
  528.                   (#_HLock dnrp)
  529.                   (%setf-macptr dnrp (%get-ptr dnrp))
  530.                   (#_StripAddress dnrp)
  531.                   (return dnrp)))
  532.                 (#_CloseResFile refnum))))
  533.           (progn
  534.             (setf (rref pb :hparamblockrec.ioDirID) dirid)        ; clobbered by _HGetFinfo
  535.             (incf (rref pb :hparamblockrec.ioFDirIndex))))))))
  536.  
  537.  
  538. (defun %open-resolver (&optional hosts-file)
  539.   (unless %resolver-code%
  540.     (let* ((err -1))
  541.       (unwind-protect
  542.         (progn
  543.           (%load-resolver-code)
  544.           (with-cstr (np (or hosts-file ""))
  545.             (when (null hosts-file) (%setf-macptr np (%null-ptr)))
  546.             (setq err (ff-call %resolver-code% :ptr np :long $openresolver :d0)))
  547.           (unless (eql err 0) (%tcp-err-disp err)))
  548.         (unless (eql err 0) (%dispose-resolver))))))
  549.  
  550. (defun %close-resolver ()
  551.   (when %resolver-code%
  552.     (ff-call %resolver-code% :long $closeresolver :d0)
  553.     (%dispose-resolver)))
  554.  
  555. (defun %dispose-resolver ()
  556.   (when %resolver-code%
  557.     (let ((code %resolver-code%))
  558.       (setq %resolver-code% nil)
  559.       (%setf-macptr code (#_RecoverHandle code))
  560.       (#_HUnlock code)
  561.       (#_DisposHandle :errchk code))))
  562.  
  563. (defun %tcp-enum-cache (resultproc userdataptr)
  564.   (%open-resolver)
  565.   (ff-call %resolver-code% :ptr userdataptr :ptr resultproc  :long $enumcache :d0))
  566.  
  567. (defun %tcp-addr-to-name (addr hostinfoptr resultproc userdataptr)
  568.   (%open-resolver)
  569.   (ff-call %resolver-code%
  570.            :ptr (or userdataptr (%null-ptr))
  571.            :ptr (or resultproc (%null-ptr))
  572.            :ptr hostinfoptr
  573.            :long addr
  574.            :long $addrtoname
  575.            :d0))
  576.  
  577. (defun tcp-addr-to-name (addr)
  578.   (setf (rref %hinfo-record% hostinfo.result) 1)
  579.   (let ((err (%tcp-addr-to-name addr %hinfo-record% %tcp-set-result-proc% nil)))
  580.     (when (eq err $cacheFault)
  581.       (while (eq (setq err (rref %hinfo-record% hostinfo.result)) 1)))
  582.     err))
  583.  
  584. (defun %tcp-str-to-addr (host-name hostinfoptr resultproc userdataptr)
  585.   (%open-resolver)
  586.   (with-cstr (np host-name)
  587.     (ff-call %resolver-code%
  588.              :ptr (or userdataptr (%null-ptr))
  589.              :ptr (or resultproc (%null-ptr))
  590.              :ptr hostinfoptr
  591.              :ptr np
  592.              :long $strtoaddr
  593.              :d0)))
  594.  
  595. (defun tcp-str-to-addr (host-name)
  596.   (setf (rref %hinfo-record% hostinfo.result) 1)
  597.   (let ((err (%tcp-str-to-addr host-name %hinfo-record% %tcp-set-result-proc% nil)))
  598.     (when (eq err $cacheFault)
  599.       (while (eq (setq err (rref %hinfo-record% hostinfo.result)) 1)))
  600.     err))
  601.  
  602. #|
  603. (defun %tcp-addr-to-str (addr strptr)
  604.   (%open-resolver)
  605.   (ff-call %resolver-code% :ptr strptr :long addr :long $addrtostr :d0))
  606. (defun tcp-addr-to-str (addr)
  607.   (%stack-block ((str 16))
  608.     (%tcp-addr-to-str addr str)
  609.     (%get-cstring str)))
  610. |#
  611.  
  612. (defun tcp-addr-to-str (addr)
  613.   (format nil "~D.~D.~D.~D"
  614.           (ldb (byte 8 24) addr)
  615.           (ldb (byte 8 16) addr)
  616.           (ldb (byte 8 8) addr)
  617.           (ldb (byte 8 0) addr)))
  618.  
  619. (defun tcp-host-address (host-name)
  620.   (if (integerp host-name)
  621.     host-name
  622.     (if (and (stringp host-name) (eql 0 (length host-name)))
  623.       (values (%tcp-getaddr))
  624.       (let ((err (tcp-str-to-addr host-name)))
  625.         (unless (eql err 0) (%tcp-err-disp err))
  626.         (rref %hinfo-record% hostinfo.addr1)))))
  627.  
  628. (defun tcp-host-cname (host-address)
  629.   (if (integerp host-address)
  630.     (setq host-address (tcp-host-address host-address)))
  631.   (let ((err (tcp-addr-to-name host-address)))
  632.     (unless (eql err 0) (%tcp-err-disp err))
  633.     ;(break "foo")
  634.     (%get-cstring %hinfo-record% 4)))
  635.  
  636. (defun tcp-host-info (host-name)
  637.   (when (integerp host-name)
  638.     (setq host-name (tcp-addr-to-str host-name)))
  639.   (let ((err (tcp-str-to-addr host-name)))
  640.     (unless (eql err 0) (%tcp-err-disp err))
  641.     (values (%get-cstring %hinfo-record% 4)
  642.             (rref %hinfo-record% hostinfo.addr1)
  643.             (rref %hinfo-record% hostinfo.addr2)
  644.             (rref %hinfo-record% hostinfo.addr3)
  645.             (rref %hinfo-record% hostinfo.addr4))))
  646.  
  647. (defparameter *tcp-error-strings*
  648.   '((-23000 . "Bad network configuration")
  649.     (-23001 . "bad IP configuration")
  650.     (-23002 . "Missing IP or LAP configuration")
  651.     (-23003 . "Error loading MacTCP")
  652.     ;#define ipBadAddr -23004 /* error in getting address */
  653.     (-23005 . "TCP connection closing")
  654.     ;#define invalidLength -23006
  655.     (-23007 . "Request conflicts with existing connection")
  656.     (-23008 . "Connection does not exist")
  657.     (-23009 . "Insufficient resources to perform TCP request")
  658.     ;#define invalidStreamPtr        -23010
  659.     ;#define streamAlreadyOpen        -23011
  660.     (-23012 . "Connection terminated")
  661.     ;#define invalidBufPtr  -23013
  662.     ;#define invalidRDS     -23014
  663.     ;#define invalidWDS        -23014
  664.     (-23015 . "TCP open failed")
  665.     (-23016 . "TCP command timeout")
  666.     ;#define duplicateSocket  -23017
  667.     ;#define ipDontFragErr  -23032  /* Packet too large to send w/o fragmenting */
  668.     (-23033 . "Destination host is not responding")
  669.     ;#define ipNoFragMemErr -23036 /* no memory to send fragmented pkt */
  670.     ;#define ipRouteErr  -23037 /* can't route packet off-net */
  671.     (-23041 . "Syntax error in host name")
  672.     ;#define cacheFault -23042
  673.     ;#define noResultProc  -23043
  674.     (-23044 . "No name server can be found for the specified domain name")
  675.     (-23045 . "Domain name does not exist")
  676.     (-23046 . "None of the known name servers are responding")
  677.     (-23047 . "The domain name server has returned an error")
  678.     ;#define outOfMemory  -23048
  679.     ))
  680.  
  681.  
  682.  
  683. (defun %tcp-err-disp (errno)
  684.   (let ((err (assq (setq errno (%word-to-int errno)) *tcp-error-strings*))
  685.         (error-fn #'error))             ; want to tail-call...
  686.     (declare (type list err))
  687.     (if err (funcall error-fn (cdr err)) (%err-disp errno))))
  688.  
  689. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  690.  
  691. (defclass tcp-stream (input-stream output-stream)
  692.   ((conn :initform nil)))
  693.  
  694. (defclass binary-tcp-stream (tcp-stream io-binary-stream)
  695.   ())
  696.  
  697. (defmethod initialize-instance ((s binary-tcp-stream)
  698.                                 &key (element-type '(unsigned-byte 8) element-type-p))
  699.   (unless (or (not element-type-p)
  700.               (eq element-type 'unsigned-byte)          ; Shorthand ...
  701.               (and (subtypep element-type '(unsigned-byte 8))
  702.                    (subtypep '(unsigned-byte 8) element-type)))
  703.     (error "element-type ~S not supported." element-type))
  704.   ; no supertype cares about :element-type
  705.   (call-next-method))
  706.  
  707. (defstruct conn         ; Don't bother doing slot-value for every little thing...
  708.   pb
  709.   write-buffer
  710.   write-bufsize
  711.   write-count
  712.   read-timeout
  713.   untyi-char
  714.   rds
  715.   rds-entries
  716.   rds-offset                         ; offset in rds to next buffer
  717.   read-count
  718.   read-bufptr)
  719.  
  720. (defmethod print-object ((self tcp-stream) stream)
  721.   (let* ((type (type-of self))
  722.          (conn (slot-value self 'conn))
  723.          (pb (when conn (conn-pb conn)))
  724.          (err (and pb (%tcp-control pb $TCPStatus t))))
  725.     (case err
  726.       ((0)
  727.        (format stream "#<~S ~S -> ~A@~A>"
  728.                type
  729.                (tcp-state-name (rref pb tcpioPB.status.connectionState))
  730.                (tcp-service-name (rref pb tcpioPB.status.remotePort))
  731.                (tcp-addr-to-str (rref pb tcpioPB.status.remoteHost))))
  732.       ((nil -23008)                     ; connection doesn't exist.
  733.        (format stream "#<~S ~S>" type :closed))
  734.       (t (%tcp-err-disp err)))))
  735.  
  736. (defun tcp-connection-state (stream)
  737.   (let* ((conn (slot-value stream 'conn))
  738.          (pb (and conn (conn-pb conn))))
  739.     (if (and pb (eq 0 (%tcp-control pb $TCPStatus t)))
  740.       (rref pb tcpioPB.status.connectionState)
  741.       0)))
  742.  
  743. (defun tcp-state-name (state)
  744.   (or (cdr (assq state
  745.                   '((0 . :closed)
  746.                     (2 . :listen)
  747.                     (4 . :syn-received)
  748.                     (6 . :syn-sent)
  749.                     (8 . :established)
  750.                     (10 . :fin-wait-1)
  751.                     (12 . :fin-wait-2)
  752.                     (14 . :close-wait)
  753.                     (16 . :closing)
  754.                     (18 . :closing-last-ack)
  755.                     (20 . :closing-time-ack))))
  756.       state))
  757.  
  758. (defun tcp-service-name (port)
  759.   (or (car (rassoc port *service-name-number-alist*))
  760.       port))
  761.  
  762. (defun tcp-stream-conn (s)
  763.   (or (slot-value s 'conn) (error "~S is closed" s)))
  764.  
  765. (defmethod stream-tyo ((s tcp-stream) char &aux (conn (tcp-stream-conn s)))
  766.   (without-interrupts
  767.    (let* ((count (conn-write-count conn)))
  768.      (when (eq count (conn-write-bufsize conn))
  769.        (tcp-stream-force-output conn nil)
  770.        (setq count (conn-write-count conn)))
  771.      (setf (conn-write-count conn) (1+ count))
  772.      (ccl:%put-byte (conn-write-buffer conn) (char-code char) count))))
  773.  
  774. (defmethod stream-force-output ((s tcp-stream))
  775.   (tcp-stream-force-output (tcp-stream-conn s) t))
  776.  
  777. (defun tcp-stream-force-output (conn push-p)
  778.   (without-interrupts
  779.    (unless (eql (conn-write-count conn) 0)
  780.      (%tcp-send (conn-pb conn) (conn-write-buffer conn) (conn-write-count conn) push-p))
  781.    (setf (conn-write-count conn) 0)))
  782.  
  783. (defmethod stream-write-vector ((s binary-tcp-stream) v start end)
  784.   (locally
  785.    (declare (fixnum start end))
  786.    (multiple-value-bind (vector offset) (array-data-and-offset v)
  787.      (declare (fixnum offset))
  788.      (setq start (+ start offset))
  789.      (do* ((conn (tcp-stream-conn s))
  790.            (writebuf (conn-write-buffer conn))
  791.            (bufsize (conn-write-bufsize conn))
  792.            (length (- (+ end offset ) start) (- length room-in-buffer))
  793.            (bufpos (conn-write-count conn) 0)
  794.            (room-in-buffer (- bufsize bufpos) bufsize))
  795.           ((<= length room-in-buffer)
  796.            (dotimes (i length (progn (incf (conn-write-count conn) length) (tcp-stream-force-output conn t)))
  797.              (ccl::%put-byte writebuf (ccl::uvref vector start) bufpos)
  798.              (setq start (1+ start) bufpos (1+ bufpos))))
  799.        (declare (fixnum length bufpos bufsize room-in-buffer))
  800.        (dotimes (i room-in-buffer)
  801.          (ccl::%put-byte writebuf (ccl::uvref vector start) bufpos)
  802.          (setq start (1+ start) bufpos (1+ bufpos)))
  803.        (setf (conn-write-count conn) bufsize)
  804.        (tcp-stream-force-output conn t)))))
  805.  
  806. (defmethod stream-read-vector ((s binary-tcp-stream) v start end)
  807.   (locally
  808.    (declare (fixnum start end))
  809.    (multiple-value-bind (vector offset) (array-data-and-offset v)
  810.      (declare (fixnum offset))
  811.      (setq start (+ start offset))
  812.      (let* ((length (- (+ end offset ) start))
  813.             (conn (tcp-stream-conn s))
  814.             (untyi-char (conn-untyi-char conn)))
  815.        (declare (fixnum length))
  816.        (if (and (> length 0) untyi-char)
  817.          (progn
  818.            (setf (ccl::uvref vector start) (char-code untyi-char)
  819.                  (conn-untyi-char conn) nil
  820.                  start (1+ start)
  821.                  length (1- length))))
  822.        (do* ((pb (conn-pb conn))
  823.              (rds (conn-rds conn)))
  824.             ((zerop length))
  825.          (when (eql (conn-read-count conn) 0)
  826.            (%tcp-nocopyrcv pb rds (conn-rds-entries conn) (conn-read-timeout conn))
  827.            (when (eql 0 (setf (conn-read-count conn) (ccl:%get-word rds)))
  828.              (tcp-stream-bfr-return conn)
  829.              (when (tcp-stream-eofp conn)    ;Can't get a character.
  830.                (return-from stream-read-vector nil))
  831.              (error "Can't read a character from ~S" s))
  832.            (ccl:%setf-macptr (conn-read-bufptr conn) (ccl:%get-ptr rds 2))
  833.            (setf (conn-rds-offset conn) 6))
  834.          (setf (ccl::uvref vector start) (ccl::%get-unsigned-byte (conn-read-bufptr conn)))
  835.          (incf start)
  836.          (ccl:%incf-ptr (conn-read-bufptr conn))
  837.          (decf length)
  838.          (when (eql (setf (conn-read-count conn) (1- (conn-read-count conn))) 0)
  839.            (let* ((rds (conn-rds conn))
  840.                   (nextbuf (conn-rds-offset conn))
  841.                   (bufptr (conn-read-bufptr conn)))
  842.              (if (eql (setf (conn-read-count conn) (ccl:%get-word rds nextbuf)) 0)
  843.                (tcp-stream-bfr-return conn)
  844.                (progn
  845.                  (ccl:%setf-macptr bufptr (ccl:%get-ptr rds (+ nextbuf 2)))
  846.                  (setf (conn-rds-offset conn) (+ nextbuf 6)))))))))))
  847.  
  848. (defmethod stream-tyi ((s tcp-stream) &aux (conn (tcp-stream-conn s)))
  849.   (without-interrupts
  850.    (if (conn-untyi-char conn)
  851.      (prog1 (conn-untyi-char conn) (setf (conn-untyi-char conn) nil))
  852.      (progn
  853.        (when (eql (conn-read-count conn) 0)
  854.          (when (tcp-stream-eofp conn)
  855.                (return-from stream-tyi nil))
  856.          (let* ((pb (conn-pb conn))
  857.                 (rds (conn-rds conn)))
  858.            (%tcp-nocopyrcv pb rds (conn-rds-entries conn) (conn-read-timeout conn))
  859.            (when (eql 0 (setf (conn-read-count conn) (ccl:%get-word rds)))
  860.              (tcp-stream-bfr-return conn)
  861.              (when (tcp-stream-eofp conn)
  862.                (return-from stream-tyi nil))
  863.              (error "Can't read a character from ~S" s))
  864.            (ccl:%setf-macptr (conn-read-bufptr conn) (ccl:%get-ptr rds 2))
  865.            (setf (conn-rds-offset conn) 6)))
  866.        (prog1 (code-char (ccl:%get-byte (conn-read-bufptr conn)))
  867.          (ccl:%incf-ptr (conn-read-bufptr conn))
  868.          (when (eql (setf (conn-read-count conn) (1- (conn-read-count conn))) 0)
  869.            (let* ((rds (conn-rds conn))
  870.                   (nextbuf (conn-rds-offset conn))
  871.                   (bufptr (conn-read-bufptr conn)))
  872.              (if (eql (setf (conn-read-count conn) (ccl:%get-word rds nextbuf)) 0)
  873.                (tcp-stream-bfr-return conn)
  874.                (progn
  875.                  (ccl:%setf-macptr bufptr (ccl:%get-ptr rds (+ nextbuf 2)))
  876.                  (setf (conn-rds-offset conn) (+ nextbuf 6)))))))))))
  877.  
  878.  
  879. (defmethod stream-read-byte ((s binary-tcp-stream))
  880.   (let* ((char (stream-tyi s)))
  881.     (if char
  882.       (locally (declare (type character char)) (char-code char)))))
  883.  
  884. (defmethod stream-write-byte ((s binary-tcp-stream) b)
  885.   (stream-tyo s (code-char (logand #xff b))))
  886.  
  887. (defun tcp-stream-bfr-return (conn)
  888.   (ccl:%setf-macptr (conn-read-bufptr conn) (ccl:%null-ptr))
  889.   (setf (conn-read-count conn) 0)        ; Usually redundant except in clear-input..
  890.   (%tcp-bfrreturn (conn-pb conn) (conn-rds conn)))
  891.  
  892. (defmethod stream-listen ((s tcp-stream) &aux (conn (tcp-stream-conn s)))
  893.   (or (conn-untyi-char conn)
  894.       (not (eql (conn-read-count conn) 0))
  895.       (let ((pb (conn-pb conn)))
  896.         (and (eql (%tcp-control pb $TCPStatus T) 0)
  897.              (> (rref pb tcpioPB.status.amtUnreadData) 0)))))
  898.  
  899.  
  900. (defmethod stream-untyi ((s tcp-stream) char)
  901.   (setf (conn-untyi-char (tcp-stream-conn s)) char))
  902.  
  903. (defmethod stream-eofp ((s tcp-stream))
  904.   (let* ((conn (tcp-stream-conn s)))
  905.     (and (null (conn-untyi-char conn))
  906.          (eql (conn-read-count conn) 0)
  907.          (tcp-stream-eofp conn))))
  908.  
  909. (defun tcp-stream-eofp (conn)
  910.   (let* ((pb (conn-pb conn))
  911.          (err (%tcp-control pb $TCPStatus t)))
  912.     (or (eq err -23008)                 ; connection doesn't exist
  913.         (if (eql err 0)
  914.           (memq (rref pb tcpioPB.status.connectionState)
  915.                 '(0                           ; Closed
  916.                   14                          ; Close Wait
  917.                   16                          ; Closing
  918.                   18                          ; Last Ack
  919.                   20))                        ; Time Wait
  920.           (%tcp-err-disp err)))))
  921.  
  922. ;Kind of bogus, but most of the protocols don't depend on a reliable close anyhow...
  923. (defmethod stream-close ((s tcp-stream) &aux (conn (slot-value s 'conn)))
  924.   (when conn
  925.     (stream-clear-input s)
  926.     (ignore-errors (tcp-stream-force-output s t))   ; Ok if fails (bogus)
  927.     (let ((pb (conn-pb conn)))
  928.       (setf (rref pb tcpioPB.close.validityFlags) 0)
  929.       (%tcp-control pb $TCPClose T)     ; Ok if fails (bogus)
  930.       (%tcp-release pb)
  931.       (#_DisposPtr pb)
  932.       (setf (slot-value s 'conn) nil))
  933.     (setq *open-tcp-streams* (delete s *open-tcp-streams* :test #'eq)))
  934.   (call-next-method))
  935.  
  936. (defmethod stream-abort ((s tcp-stream)) ;called before stream-close for abort.
  937.   (stream-clear-input s)
  938.   (%tcp-control (conn-pb (tcp-stream-conn s)) $tcpAbort T))       ; Ok if fails
  939.  
  940. (defmethod stream-clear-input ((s tcp-stream))
  941.   (let ((conn (tcp-stream-conn s)))
  942.     (setf (conn-untyi-char conn) nil)
  943.     (unless (eql 0 (conn-read-count conn))
  944.       (tcp-stream-bfr-return conn))))
  945.  
  946. (defmethod initialize-instance ((s tcp-stream) &key
  947.                                 host
  948.                                 port
  949.                                 (tcpbufsize 8192)
  950.                                 (rdsentries 6)
  951.                                 (writebufsize 1024)
  952.                                 notify-proc
  953.                                 (commandtimeout 30))
  954.   (call-next-method)
  955.   (let (pb)
  956.     (unless (integerp port)
  957.       (setq port (or (cdr (assoc (require-type port '(or string symbol))
  958.                                  *service-name-number-alist* :test #'string-equal))
  959.                      (error "Unknown port ~S" port))))
  960.     (when host
  961.       (setq host (tcp-host-address host)))
  962.     (unwind-protect
  963.       (progn
  964.         (setq pb (#_NewPtr :clear :errchk (+ $tcpPBSize tcpbufsize writebufsize (+ (* 6 rdsentries) 2))))
  965.         (%tcp-create pb (ccl:%inc-ptr pb $tcpPBSize) tcpbufsize notify-proc)
  966.         (if host
  967.           (%tcp-active-open pb host port)
  968.           (%tcp-passive-open pb port commandtimeout))
  969.         (setf (slot-value s 'conn)
  970.               (make-conn :pb pb
  971.                          :write-buffer (ccl:%inc-ptr pb (+ $tcpPBSize tcpbufsize))
  972.                          :write-bufsize writebufsize
  973.                          :write-count 0
  974.                          :read-timeout commandtimeout
  975.                          :untyi-char nil
  976.                          :rds (ccl:%inc-ptr pb (+ $tcpPBSize tcpbufsize writebufsize))
  977.                          :rds-entries rdsentries
  978.                          :rds-offset 0
  979.                          :read-count 0
  980.                          :read-bufptr (ccl:%null-ptr)))
  981.         (setq pb nil)
  982.         (push s *open-tcp-streams*)
  983.         s)
  984.       (when pb
  985.         (unless (ccl:%null-ptr-p (rref pb tcpioPB.StreamPtr))
  986.           (%tcp-control pb $TCPRelease T))
  987.         (#_DisposPtr pb)))))
  988.  
  989. (defun open-tcp-stream (host port &key (element-type 'character)
  990.                                 (tcpbufsize 8192)
  991.                                 (rdsentries 6)
  992.                                 (writebufsize 1024)
  993.                                 notify-proc
  994.                                 (commandtimeout 30))
  995.   (if (subtypep element-type 'character)
  996.     (make-instance 'tcp-stream
  997.       :host host :port port
  998.       :tcpbufsize tcpbufsize
  999.       :rdsentries rdsentries
  1000.       :writebufsize writebufsize 
  1001.       :notify-proc notify-proc
  1002.       :commandtimeout commandtimeout)
  1003.     (make-instance 'binary-tcp-stream
  1004.       :element-type element-type
  1005.       :host host :port port
  1006.       :tcpbufsize tcpbufsize
  1007.       :rdsentries rdsentries
  1008.       :writebufsize writebufsize 
  1009.       :notify-proc notify-proc
  1010.       :commandtimeout commandtimeout)))
  1011.  
  1012.  
  1013. ;;Useful little functions: read & write CRLF-terminated lines from a "clear text" 
  1014. ;; connection.
  1015. (defun telnet-read-line (stream)
  1016.   "Read a CRLF-terminated line"
  1017.   (unless (ccl:stream-eofp stream)
  1018.     (let ((line (Make-Array 10 :Element-Type 'Character :Adjustable T :Fill-Pointer 0))
  1019.           (char nil))
  1020.       (do () ((or (null (setq char (ccl:stream-tyi stream)))
  1021.                   (and (eq char #\CR) (eq (ccl:stream-peek stream) #\LF)))
  1022.               (when char (ccl:stream-tyi stream))
  1023.               (values line (null char)))
  1024.         (vector-push-extend char line)))))
  1025.  
  1026. (defun telnet-write-line (stream string &rest args)
  1027.   "Write a CRLF-terminated line"
  1028.   (declare (dynamic-extent args))
  1029.   (apply #'format stream string args)
  1030.   (write-char #\CR stream)
  1031.   (write-char #\LF stream)
  1032.   (force-output stream))
  1033.  
  1034. ;; Before quitting ...
  1035.  
  1036. (defun cleanup-after-mactcp ()
  1037.   (do* ()
  1038.        ((null *open-tcp-streams*))
  1039.     (close (car *open-tcp-streams*)))
  1040.   (%close-resolver))
  1041.  
  1042. (pushnew #'cleanup-after-mactcp *lisp-cleanup-functions* :key #'function-name :test #'eq)
  1043.